Shareware Grab Bag/Shareware Grab Bag.iso/002/bibloghy.arc/INPUT.PAS

Pascal/Delphi Source File | 1984-06-17 | 6.8 KB | 331 lines

{$debug-}

program in_put(input,output,outfile);

var
  outfile : text;
  number  : string (6);
  inline  : lstring (255);
  hold    : lstring (255);
  done    : boolean;
  count   : word;
  inkey   : char;
  special : boolean;
  on_entry: boolean;
  reshow  : boolean;

value
  done     := false;
  on_entry := true;
  count    := 0;
  number   := '000001';
  inline   := null;
  hold     := null;

const
  f1   = chr (59);
  f2   = chr (60);
  f10  = chr (68);
  bs   = chr (08);
  left = chr (75);
  rc   = chr (13);

procedure csrloc (x: word);
  external;

procedure chrget (var x: word);
  external;

procedure next_key;
  var [static]
    x  : word;
    lo : byte;
    hi : byte;
  begin
    chrget (x);
    lo := lobyte (x);
    hi := hibyte (x);
    if lo = 0 then
      begin
        special := true;
        inkey   := chr (hi);
      end
    else
      begin
        special := false;
        inkey   := chr (lo);
      end;
  end;

procedure clear_line;
  var [static]
    blanks79 : string (79);
    first    : boolean;
    i        : word;
  value
    first    := true;
  begin
    if first then
      begin
        first := false;
        for i := 1 to 79 do
          blanks79 [i] := ' ';
      end;
    csrloc (6144);
    write (blanks79);
    csrloc (6144);
  end;

procedure show_so_far_after_clear;
  begin
    if on_entry then
      write (number,'=',inline)
    else
      write ('Enter new page number : ',inline);
  end;

procedure show_so_far;
  begin
    clear_line;
    show_so_far_after_clear;
  end;

procedure strip_blanks;
  var [static]
    i      : word;
  begin
    if (inline.len > 0) and (inline[1] = ' ') then
      reshow := true
    else
      reshow := false;
    { strip leading blanks }
    while (inline.len > 0) and then (inline [1] = ' ') do
      begin
        for i := 2 to inline.len do
          inline [i-1] := inline [i];
        inline.len := inline.len - 1;
      end;
    { strip trailing blanks }
    while (inline.len > 0) and then (inline [inline.len] =  ' ') do
      inline.len := inline.len - 1;
  end;

procedure digest_number;
  var [static]
    all_numeric  : boolean;
    i            : word;
    j            : word;
  begin
    strip_blanks;
    if inline = null then
      begin
        number := '000001';
        return;
      end;
    all_numeric := true;
    for i := 1 to inline.len do
      if not (inline [i] in ['0'..'9']) then
        begin
          all_numeric := false;
          break;
        end;
    if all_numeric then
      begin
        number := '000000';
        for i := 6 downto 1 do
          begin
            if inline.len < (7-i) then
              break
            else
              number [i] := inline [inline.len + i - 6];
          end;
      end
    else
      begin
        number := '      ';
        if inline.len < 6 then
          j := inline.len
        else
          j := 6;
        for i := 1 to j do
          number [i] := inline [i];
      end;
  end;

procedure increment;
  var [static]
    i     : word;
    j     : word;
    carry : boolean;
  begin
    i := 7;
    for j := 6 downto 2 do
      if number [j] = ' ' then
        i := j
      else
        break;
    repeat
      carry := false;
      i := i - 1;
      if i = 0 then
        return;
      if number [i] in ['0'..'9'] then
        if number [i] = '9' then
          begin
            number [i] := '0';
            carry := true;
          end
        else
          number [i] := chr (1 + ord (number [i]))
      else
        begin
          for j := 6 downto (i+2) do
            number [j] := number [j-1];
          if i < 6 then
          number [i+1] := '1';
        end;
    until not carry;
  end;

procedure initialize;
  var [static]
    i : word;
  begin
    rewrite (outfile);
    for i := 1 to 25 do
      writeln;
    writeln ('Index data entry program (C) Copyright Peter Norton 1983');
    writeln;
    writeln ('Function keys :  f1 - enter new page number');
    writeln ('                 f2 - increment page number');
    writeln ('                f10 - end operation');
    writeln;
    writeln (' Page = Index entry description');
    writeln ('______ _____________________________________________________');
    show_so_far;
  end;

procedure process_rc;
  begin
    if on_entry then
      begin
        strip_blanks;
        if inline.len = 0 then
          return;
        count := count + 1;
        if reshow then
          show_so_far;
        writeln (outfile,number,'=',inline);
        writeln;
        if special and (inkey = f10) then
          return;
        inline := null;
        show_so_far_after_clear;
      end
    else
      begin
        on_entry := true;
        digest_number;
        inline := hold;
        show_so_far;
      end;
  end;

procedure process_f10;
  begin
    if on_entry and (inline.len > 0) then
      process_rc;
    done := true;
  end;

procedure process_regular;
  begin
    if inline.len > 71 then
      begin
        write (chr(7));
        return;
      end;
    inline.len := inline.len + 1;
    inline [inline.len] := inkey;
    write (inkey);
  end;

procedure process_invalid_special;
  begin
    clear_line;
    writeln;
    writeln ('Special key ignored.');
    writeln;
    write (chr(7));
    show_so_far;
  end;

procedure process_f1;
  begin
    if not on_entry then
      begin
        process_invalid_special;
        return;
      end;
    on_entry := false;
    hold := inline;
    inline := null;
    show_so_far;
  end;

procedure process_f2;
  begin
    if not on_entry then
      begin
        process_invalid_special;
        return;
      end;
    increment;
    show_so_far;
  end;

procedure process_bs;
  begin
    if inline.len > 0 then
      begin
        inline.len := inline.len - 1;
        write (bs,' ',bs);
      end
    else
      show_so_far;
  end;

procedure process_input;
  begin
    next_key;
    if special then
      case inkey of
         f1:      process_f1;
         f2:      process_f2;
        f10:      process_f10;
        left:     process_bs;
        otherwise process_invalid_special;
      end
    else
      case inkey of
        rc:       process_rc;
        bs:       process_bs;
        otherwise process_regular;
      end;
  end;

procedure finish_up;
  begin
    close (outfile);
    writeln;
    writeln (count,' index entries written.');
  end;

begin
  initialize;
  repeat
    process_input
  until done;
  finish_up;
end.